Optional Surfaces.f

Requires OpenGL
Requires SDL
Requires SDL-image
Requires Kagi
Requires Tools
Requires Seki
Requires Vectors
Requires Dorothy

Only Forth Definitions

Variable colorkey \ internal

type: texture end-type

type: rectangle
   short.field x
   short.field y
   short.field w
   short.field h
end-type

method: rectangle.@  x.@ y.@ w.@ h.@ ;
method: rectangle.!  h.! w.! y.! x.! ;
method: rectangle.?  x.? y.? w.? h.? ;
macro: rectangle.dims  rectangle.w.2@ ;
macro: rectangle.xy   rectangle.x.2@ ;
macro: rectangle.dims!  rectangle.w.2! ;
macro: rectangle.xy!  rectangle.x.2! ;


Type: sdlformat
   int.field palette
   byte.field BitsPerPixel
   byte.field BytesPerPixel
   byte.field Rloss
   byte.field Gloss
   byte.field Bloss
   byte.field Aloss
   byte.field Rshift
   byte.field Gshift
   byte.field Bshift
   byte.field Ashift
   int.field Rmask
   int.field Gmask
   int.field Bmask
   int.field Amask
   int.field colorkey
   byte.field alpha
end-type

Type: surface
   int.field flags
   sdlformat.pointer format
   int.field w
   int.field h
   int.field pitch
   int.pointer pixels
   int.skip
   int.skip
   rectangle.field cliprect
   int.skip
   int.skip
   int.skip
   int.skip
   int.skip
end-type

macro: surface.dims  surface.w.2@ ;
macro: surface.width   surface.w.@ ;
macro: surface.height   surface.h.@ ;
macro: surface.has-alpha?  surface.format.amask.@  0<> ;

: surface.components  has-alpha? if 4 else 3 then ;
: surface.red-first?  format.rmask.@ $ff = ;

: surface.texformat ( surface -- glformat )
   dup has-alpha? IF
      red-first? IF GL_RGBA ELSE GL_BGRA THEN
   ELSE
      red-first? IF GL_RGB ELSE GL_BGR THEN
   THEN ;

: surface.pixel[]   ( x y surface --   addr )
   dup >r width * + r> pixels.[] ;

\ Fetch color key from LAST pixel in SDL surface.
: surface.@ck   ( surface -- surface )
   dup dup dims 1 1 2- pixel[].@ colorkey ! ;

\ create an alpha mask using colorkey.
: surface.colorkey-alpha   ( surface -- surface )
   @ck dup dup 0 0 pixel[] swap dims * 0 do dup @ dup colorkey @ = if $ffffff and then !+ loop drop ;

: new-surface  ( w h -- surface | false )
   dup if
      SDL_CreateRGBSurface( SDL_SWSURFACE -rot 32 $ff0000 $ff00 $ff $ff000000 )
   else
      nip
   then ;

method: surface.blit  ( src rect rect -- )
   third 0 255 sdl_setalpha
   this swap SDL_BlitSurface ;

method: surface.copy  ( -- surface2 )
  this 0 255 SDL_SetAlpha
  dims .s new-surface
  dup >r  this  0  0  r> surface.blit  ;

macro: surface.destroy  SDL_FreeSurface ;

method: surface.make-32bit
  copy  this.destroy ;

method: surface.resize  ( w h -- surface2 ) \ doesn't delete surface
   this 0 255 SDL_SetAlpha   new-surface >r  0 r@ 0 blit  r> ;

method: surface.>power/2   ( -- surface2 )  \ doesn't delete surface
   dims power/2 swap power/2 swap resize ;

method: surface.maketex  ( -- texture )
   new-texture
   glPixelStorei( GL_UNPACK_ROW_LENGTH  0 )
   glTexImage2D( GL_TEXTURE_2D  0   GL_RGBA8   dims   0   texformat   GL_UNSIGNED_BYTE   0 0 pixel[] ) ;

: texture.destroy ( texure -- )
  ?dup if glDeleteTextures( 1 sp@ cell+ ) drop then ;

: surface.prepare
   make-32bit  colorkey-alpha
   dup >power/2 swap destroy
   ; \ cr ." Converted surface: " dup dims swap . ." x " . ."  Colorkey: " colorkey @ h. ;



macro: texture.bind   bind-texture ;

0 texture.ref t
0 rectangle.ref rect
0 surface.ref s

method: surface.updatetex ( sdlrect texture -- )
   to t to rect
   t.bind
   glPixelStorei( GL_UNPACK_ROW_LENGTH  width )
   glTexSubimage2D( GL_TEXTURE_2D  0  rect.@  texformat  GL_UNSIGNED_BYTE  rect.xy pixel[] )  ;
